home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / forthcmp.zip / DEFINING.4TH < prev    next >
Text File  |  1992-03-30  |  4KB  |  132 lines
  1. \ ForthCMP  Defining Word Examples
  2.  
  3. \ COPYRIGHT 1985 (C) BY THOMAS ALMY.  ALL RIGHTS RESERVED
  4.  
  5. \ Permission is granted to registered users of ForthCMP to sell or distribute
  6. \ computer programs incorporating the compiled contents of this file.
  7.  
  8. \ THIS FILE CONTAINS DEFINING WORD EXAMPLES FOR TWO DIMENSIONAL
  9. \  VECTORED ARRAYS, VARIABLES IN ROM SPACE, AND PRINTING IN
  10. \  SPECIFIC BASES.
  11.  
  12.  
  13.     100 MSDOS                   \ select one of these
  14. \   10000 100 MSDOSEXE
  15.  
  16.  
  17.  
  18.  
  19. \ 2 Dimensional Integer Array                           03/19/85
  20.  
  21. SEPDSEG? #IF  ( handle romable and ram versions differently )
  22. PRIMITIVE ( defined arrays are primitive )
  23. H: ARRAY2D  ( rows columns --- )
  24.    CSEG CREATE                  \ header & vector in CSEG
  25.    SWAP 0 DO                    \ build vector
  26.      DSEG HERE ,                \ pointer to row
  27.      DUP 2* ALLOT               \ row allocated in DSEG
  28.    LOOP DROP
  29.  
  30.  DOES>   ( row# column# -- address )
  31.    ROT 2* + CS: @               \ address of row
  32.    SWAP 2* +        ;           \ address of element
  33.  
  34. #ELSE
  35.  
  36. PRIMITIVE ( defined arrays are primitive )
  37. H: ARRAY2D  ( rows columns --- )
  38.    CREATE                       \ header & vector
  39.    2DUP * 2* -ROT               \ remember array size
  40.    OVER 2* HERE + ROT 0 DO      \ fill in vector
  41.      DUP , OVER 2* + LOOP
  42.    2DROP  ALLOT                 \ allocate array space
  43.  
  44.  DOES>   ( row# column# -- address )
  45.    ROT 2* + @                   \ address of row
  46.    SWAP 2* +        ;           \ address of element
  47. #THEN
  48.  
  49.  
  50. \ 2 Dimensional Character Array                         03/19/85
  51.  
  52. SEPDSEG? #IF  ( handle romable and ram versions differently )
  53. PRIMITIVE ( defined arrays are primitive )
  54. H: CARRAY2D  ( rows columns --- )
  55.    CSEG CREATE                  \ header & vector in CSEG
  56.    SWAP 0 DO                    \ build vector
  57.      DSEG HERE ,                \ pointer to row
  58.      DUP ALLOT                  \ space allocated in DSEG
  59.    LOOP DROP
  60.  
  61.  DOES>   ( row# column# -- address )
  62.    ROT 2* + CS: @               \ address of row
  63.    +                ;           \ address of element
  64.  
  65. #ELSE
  66.  
  67. PRIMITIVE ( defined arrays are primitive )
  68. H: CARRAY2D  ( rows columns --- )
  69.    CREATE                       \ header & vector
  70.    2DUP * -ROT                  \ remember array size
  71.    OVER 2* HERE + ROT 0 DO      \ fill in vector
  72.      DUP , OVER  +  LOOP
  73.    2DROP  ALLOT                 \ allocate array space
  74.  
  75.  DOES>   ( row# column# -- address )
  76.    ROT 2* + @                   \ address of row
  77.    +                ;           \ address of element
  78. #THEN
  79.  
  80.  
  81. \ Variable in rom                                       03/19/85
  82.  
  83. H: Variable  CSEG CREATE 0 , ;
  84.  
  85. 0 #IF
  86. In programs with separate code and data segments, this creates a
  87.  variable in the code segment. Such a variable can be used at
  88. cross-compile time and fetched at runtime.  The variable can be
  89. stored into at runtime if the code segment is in RAM memory.
  90. #THEN
  91.  
  92.  
  93.  
  94.  
  95.  
  96. \ Base Print                                            03/19/85
  97.  
  98. 2 0 IN/OUT  \ at runtime, two arguments: value to print and
  99.             \ the pointer to the desired numeric base  
  100.  
  101. H: BASE.   ( base -- )
  102.      CSEG CREATE ,              \ compile desired base
  103.      DOES>  ( value -- )
  104.      BASE @ -ROT                \ save current base
  105.      CS: @ BASE !               \ set base from parameter field
  106.      .                          \ print the value
  107.      BASE ! ;                   \ restore original base
  108.  
  109. ( CS: needed only if separate data and code segments )
  110.  
  111.  
  112. \ Test of array words and base print words
  113.  
  114. 2 4 ARRAY2D  ARRAY1    2 4 CARRAY2D  ARRAY2
  115.  
  116. : ARRAYTEST 0  CR   HEX
  117.     2 0 DO 4 0 DO DUP J I ARRAY1 DUP . !
  118.                   DUP J I ARRAY2 DUP . C!  1+ LOOP LOOP
  119.     DROP  CR
  120.    8 0 DO ['] ARRAY1 >BODY CS: @ I 2* + @ .  LOOP  CR
  121.    8 0 DO ['] ARRAY2 >BODY CS: @ I + C@ . LOOP CR ;
  122.  
  123. 8 BASE. O.    16 BASE. H.
  124.  
  125. : BASETEST 16 0 DO I . I O. I H. CR LOOP ;
  126. : MAIN  DECIMAL BASETEST ARRAYTEST ;
  127.  
  128.  
  129. INCLUDE FORTHLIB
  130. END
  131.  
  132.